home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Magnum One
/
Magnum One (Mid-American Digital) (Disc Manufacturing).iso
/
d18
/
vis082s.arc
/
DATABASE.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1991-04-17
|
17KB
|
661 lines
{ Revision History
881026 - Cleaned up Group / Level access
- Troglodyte
}
{$R-,S-,I-,D-,F+,V-,B-,N-,L+,O+ }
unit database;
Interface
uses crt,gentypes,gensubs,subs1,subs2,overret1;
Procedure datamenu;
Implementation
Procedure datamenu;
Var curbase:baserec;
curbasenum:Integer;
Procedure packentry(Var p:parsedentry;Var a:anystr);
Var cnt:Integer;
Begin
a:='';
For cnt:=1 To curbase.numcats Do
If Length(a)+Length(p[cnt])>254 Then Begin
WriteLn('Entry to big, truncated.');
exit
End Else a:=a+p[cnt]+#1
End;
Procedure parseentry(Var oa:anystr;Var p:parsedentry);
Var d,cnt:Integer;
a:anystr;
Begin
a:=oa;
For cnt:=1 To curbase.numcats Do Begin
d:=Pos(#1,a);
If d=0
Then p[cnt]:=''
Else
Begin
p[cnt]:=Copy(a,1,d-1);
a:=Copy(a,d+1,255)
End
End
End;
Procedure makenewbase;
Function getnumber(r1,r2:Integer;txt:mstr):Integer;
Var t:Integer;
Begin
Repeat
writestr(txt+':');
t:=valu(Input);
If (t<r1) Or (t>r2) Then
WriteLn('Sorry, must be from ',r1,' to ',r2,'.')
Until (t>=r1) And (t<=r2);
getnumber:=t
End;
Var n,cnt:Integer;
b:baserec;
p:parsedentry;
Begin
n:=FileSize(ddfile)+1;
writehdr('Create database number '+strr(n));
writestr('Database name:');
If Length(Input)=0 Then exit;
b.basename:=Input;
Writestr(^M'Conference number (Return=None) :*');
b.conference:=0;
b.conference:=valu(input);
if (b.conference>32) then b.conference:=0;
if (b.conference=0) then begin
writestr('Access level [1] :');
If Length(Input)=0
Then b.level:=1
Else b.level:=valu(Input);
end
else
b.level := maxint ;
b.numcats:=getnumber(1,maxcats,'Number of categories');
b.numents:=0;
For cnt:=1 To b.numcats Do Begin
writestr('Category #'+strr(cnt)+' name:');
If Length(Input)=0 Then exit;
p[cnt]:=Input
End;
curbase:=b;
packentry(p,b.catnames);
Seek(ddfile,n-1);
Write(ddfile,b);
WriteLn('Database created!');
writelog(7,2,b.basename);
curbase:=b;
curbasenum:=n
End;
Function Hasaccess(X:baserec):Boolean;
Var cnt,a:Integer;
b,d:anystr;
e:Boolean;
Begin
e:=False;
If (X.conference>0) Then
If (urec.confset[x.conference]>0) Then e:=True;
if (x.conference=0) then
if (ulvl>x.level) then e:=true;
hasaccess:=e;
End;
Procedure nobases;
Begin
close(ddfile);
Rewrite(ddfile); close(ddfile);
WriteLn('No databases exist!');
If Not issysop Then exit;
writestr('Create first database now? *');
If Not yes Then exit;
reset(ddfile);
makenewbase
End;
Procedure openddfile;
Begin
Assign(ddfile,'DataDir');
Reset(ddfile);
If IOResult<>0
Then nobases
Else Begin
Reset(ddfile);
If FileSize(ddfile)=0 Then Begin
Close(ddfile);
nobases
End
End
End;
Procedure writecurbase;
Begin
Seek(ddfile,curbasenum-1);
Write(ddfile,curbase)
End;
Procedure readcurbase;
Begin
Seek(ddfile,curbasenum-1);
Read(ddfile,curbase)
End;
Procedure openefile;
Var i:Integer;
Begin
readcurbase;
If isopen(efile) Then Close(efile);
i:=IOResult;
Assign(efile,'Database.'+strr(curbasenum));
Reset(efile);
If IOResult<>0 Then Rewrite(efile);
curbase.numents:=FileSize(efile);
writecurbase
End;
Function getparsedentry(Var p:parsedentry):Boolean;
Var cnt:Integer;
pr:parsedentry;
nonblank:Boolean;
Begin
nonblank:=False;
parseentry(curbase.catnames,pr);
WriteLn('(*=',unam,')');
For cnt:=1 To curbase.numcats Do Begin
writestr(pr[cnt]+': &');
If Length(Input)>0 Then nonblank:=True;
If Input='*'
Then p[cnt]:=unam
Else p[cnt]:=Input
End;
getparsedentry:=nonblank
End;
Function getentry(Var a:anystr):Boolean;
Var p:parsedentry;
Begin
getentry:=getparsedentry(p);
packentry(p,a)
End;
Const shownumbers:Boolean=False;
Procedure showparsedentry(Var p:parsedentry);
Var cnt:Integer;
pr:parsedentry;
Begin
parseentry(curbase.catnames,pr);
For cnt:=1 To curbase.numcats Do Begin
If shownumbers Then Write(cnt,'. ');
WriteLn(pr[cnt],': '^S,p[cnt]);
If break Then exit
End;
shownumbers:=False
End;
Procedure showentry(Var a:anystr);
Var p:parsedentry;
Begin
parseentry(a,p);
showparsedentry(p)
End;
Procedure showentrynum(Var a:anystr;num:Integer);
Begin
WriteLn(^M,num,':');
showentry(a)
End;
Function noentries:Boolean;
Begin
If curbase.numents>0
Then noentries:=False
Else
Begin
WriteLn('Sorry, database is empty!');
noentries:=True
End
End;
Procedure changeentryrec(Var e:entryrec);
Var p:parsedentry;
c:Integer;
done:Boolean;
Begin
parseentry(e.data,p);
Repeat
shownumbers:=True;
showparsedentry(p);
writestr(^M'Category number to change [CR to exit]:');
done:=Length(Input)=0;
If Not done Then Begin
c:=valu(Input);
If (c>0) And (c<=curbase.numcats) Then Begin
writestr('New value [*=Your name, CR to leave unchanged]: &');
If Length(Input)<>0 Then
If Input='*'
Then p[c]:=unam
Else p[c]:=Input
End
End
Until done;
packentry(p,e.data)
End;
Procedure adddata;
Var e:entryrec;
Begin
writehdr('Add an entry');
If Not getentry(e.data) Then Begin
WriteLn('Blank entry!');
exit
End;
writestr(^M'Make changes (Y/N/X)? *');
If Length(Input)<>0 Then
Case UpCase(Input[1]) Of
'X' :Begin
writestr('Entry not added.');
exit
End;
'Y' :changeentryrec(e)
End;
e.when:=now;
e.addedby:=unum;
Seek(efile,curbase.numents);
Write(efile,e);
curbase.numents:=curbase.numents+1;
writecurbase
End;
Procedure listdata;
Var cnt,f,l:Integer;
e:entryrec;
Begin
If noentries Then exit;
WriteLn;
parserange(curbase.numents,f,l);
If f=0 Then exit;
WriteLn;
For cnt:=f To l Do Begin
Seek(efile,cnt-1);
Read(efile,e);
showentrynum(e.data,cnt);
If break Then exit
End
End;
Function getdatanum(txt:mstr):Integer;
Var n:Integer;
Begin
getdatanum:=0;
If noentries Then exit;
Repeat
writestr(^M'Entry to '+txt+' [?=list]:');
If Length(Input)=0 Then exit;
If Input='?' Then Begin
listdata;
Input:=''
End
Until Length(Input)>0;
n:=valu(Input);
If (n>0) And (n<=curbase.numents) Then getdatanum:=n
End;
Function notuseradded(Var e:entryrec):Boolean;
Var b:Boolean;
Begin
b:=Not((e.addedby=unum) Or issysop);
notuseradded:=b;
If b Then writestr('You didn''t add this entry!')
End;
Procedure changedata;
Var n:Integer;
e:entryrec;
Begin
n:=getdatanum('change');
If n=0 Then exit;
Seek(efile,n-1);
Read(efile,e);
If notuseradded(e) Then exit;
writelog(8,3,Copy(e.data,1,Pos(#1,e.data)-1));
changeentryrec(e);
Seek(efile,n-1);
Write(efile,e);
End;
Procedure deletedata;
Var n,cnt:Integer;
e:entryrec;
p:parsedentry;
Begin
n:=getdatanum('delete');
If n=0 Then exit;
Seek(efile,n-1);
Read(efile,e);
If notuseradded(e) Then exit;
parseentry(e.data,p);
writelog(8,6,p[1]);
curbase.numents:=curbase.numents-1;
writecurbase;
For cnt:=n To curbase.numents Do Begin
Seek(efile,cnt);
Read(efile,e);
Seek(efile,cnt-1);
Write(efile,e)
End;
Seek(efile,curbase.numents);
Truncate(efile)
End;
Procedure listbases;
Var cnt:Integer;
b:baserec;
Begin
writehdr('List of Databases');
If break Then exit;
For cnt:=1 To FileSize(ddfile) Do Begin
Seek(ddfile,cnt-1);
Read(ddfile,b);
If hasaccess(b) Then WriteLn(cnt,'. ',b.basename);
If break Then exit
End
End;
Procedure selectdata;
Var n:Integer;
b:baserec;
Begin
If Length(Input)>1 Then Input:=Copy(Input,2,255) Else
Repeat
writestr('Database number [?=list]:');
If Length(Input)=0 Then exit;
If Input='?' Then Begin
listbases;
Input:=''
End
Until Length(Input)>0;
n:=valu(Input);
If (n<1) Or (n>FileSize(ddfile)) Then Begin
WriteLn('No such database: '^S,n);
If Not issysop Then exit;
n:=FileSize(ddfile)+1;
writestr('Create database #'+strr(n)+'? *');
If yes Then Begin
writecurbase;
makenewbase;
openefile
End;
exit
End;
Seek(ddfile,n-1);
Read(ddfile,b);
If Not hasaccess(b) Then Begin
reqlevel(b.level);
exit
End;
writecurbase;
curbasenum:=n;
openefile
End;
Procedure searchdata;
Var cnt,f,en:Integer;
e:entryrec;
Pattern:anystr;
p:parsedentry;
Begin
If noentries Then exit;
writestr('Search pattern:');
If Length(Input)=0 Then exit;
Pattern:=Input;
For cnt:=1 To Length(Pattern) Do Pattern[cnt]:=UpCase(Pattern[cnt]);
For en:=1 To curbase.numents Do Begin
Seek(efile,en-1);
Read(efile,e);
parseentry(e.data,p);
For f:=1 To curbase.numcats Do Begin
For cnt:=1 To Length(p[f]) Do p[f][cnt]:=UpCase(p[f][cnt]);
If Pos(Pattern,p[f])<>0 Then showentrynum(e.data,en)
End
End;
WriteLn(^M'Search complete')
End;
Const beenaborted:Boolean=False;
Function aborted:Boolean;
Begin
If beenaborted Then Begin
aborted:=True;
exit
End;
aborted:=xpressed Or hungupon;
If xpressed Then Begin
beenaborted:=True;
WriteLn(^B'Newscan aborted!')
End
End;
Procedure newscan;
Var first,cnt:Integer;
nd:Boolean;
e:entryrec;
Begin
beenaborted:=False;
first:=curbase.numents;
nd:=True;
While (first>0) And nd Do Begin
Seek(efile,first-1);
Read(efile,e);
nd:=e.when>laston;
If nd Then first:=first-1
End;
For cnt:=first+1 To curbase.numents Do Begin
Seek(efile,cnt-1);
Read(efile,e);
If aborted Then exit;
showentrynum(e.data,cnt)
End
End;
Procedure newscanall;
Begin
writehdr('New-scanning... Press [X] to abort.');
curbasenum:=1;
While curbasenum<=FileSize(ddfile) Do Begin
If aborted Then exit;
openefile;
If hasaccess(curbase) Then Begin
WriteLn(^B^M'Scanning ',curbase.basename,^M);
newscan;
If aborted Then exit
End;
curbasenum:=curbasenum+1
End;
curbasenum:=1;
openefile;
WriteLn(^B'Newscan complete!')
End;
Procedure killdatabase;
Var b:baserec;
cnt:Integer;
Begin
writestr('Kill database: Are you sure? *');
If Not yes Then exit;
writecurbase;
Close(efile);
Erase(efile);
For cnt:=curbasenum To FileSize(ddfile)-1 Do Begin
Seek(ddfile,cnt);
Read(ddfile,b);
Seek(ddfile,cnt-1);
Write(ddfile,b);
Assign(efile,'Database.'+strr(cnt+1));
Rename(efile,'Database.'+strr(cnt))
End;
Seek(ddfile,FileSize(ddfile)-1);
Truncate(ddfile);
writelog(8,5,'');
If FileSize(ddfile)>0 Then Begin
curbasenum:=1;
openefile
End
End;
Procedure reorderdata;
Var numd,curd,newd:Integer;
b1,b2:baserec;
f1,f2:File;
fn1,fn2:sstr;
Label exit;
Begin
writecurbase;
writehdr('Re-order databases');
writelog(8,1,'');
numd:=FileSize(ddfile);
WriteLn('Number of database: ',numd);
For curd:=0 To numd-2 Do Begin
Repeat
writestr('New database #'+strr(curd+1)+' [?=List, CR to quit]:');
If Length(Input)=0 Then GoTo exit;
If Input='?'
Then
Begin
listbases;
newd:=-1
End
Else
Begin
newd:=valu(Input)-1;
If (newd<0) Or (newd>=numd) Then Begin
WriteLn('Not found! Please re-enter...');
newd:=-1
End
End
Until (newd>0);
Seek(ddfile,curd);
Read(ddfile,b1);
Seek(ddfile,newd);
Read(ddfile,b2);
Seek(ddfile,curd);
Write(ddfile,b2);
Seek(ddfile,newd);
Write(ddfile,b1);
fn1:='Database.';
fn2:=fn1+strr(newd+1);
fn1:=fn1+strr(curd+1);
Assign(f1,fn1);
Assign(f2,fn2);
Rename(f1,'Temp$$$$');
Rename(f2,fn1);
Rename(f1,fn2)
End;
exit:
curbasenum:=1;
openefile
End;
Procedure renamedata;
Begin
WriteLn('Current name: '^S,curbase.basename);
writestr('Enter new name:');
If Length(Input)>0 Then Begin
curbase.basename:=Input;
writecurbase;
writelog(8,2,Input)
End
End;
Procedure setlevel;
Begin
writeln('Current Conference: '^S,curbase.conference);
writestr('Enter New Conference:');
if length(input)<>0 then curbase.conference:=valu(input);
if (curbase.conference>32) then curbase.conference:=0;
WriteLn('Current level: '^S,curbase.level);
writestr('Enter new level:');
If Length(Input)<>0 Then
curbase.level:=valu(Input)
else
curbase.level := maxint ;
Writestr ( 'Save changes [N,y]:' ) ;
if length(input) = 0 then exit ;
if upcase(input[1]) = 'Y' then
begin
writecurbase;
writelog(8,4,strr(curbase.level))
end ;
End;
Procedure sysopcommands;
Var q:Integer;
Begin
writelog(7,1,curbase.basename);
Repeat
q:=menu('Database Sysop','DSYSOP','QCDEKOR');
Case q Of
2:changedata;
3:deletedata;
4:setlevel;
5:killdatabase;
6:reorderdata;
7:renamedata
End
Until (q=1) Or hungupon Or (FileSize(ddfile)=0)
End;
Var q:Integer;
Begin
cursection:=databasesysop;
openddfile;
If FileSize(ddfile)=0 Then begin
close(ddfile);
exit end;
curbasenum:=1;
Seek(ddfile,0);
Read(ddfile,curbase);
If Not hasaccess(curbase) Then Begin
reqlevel(curbase.level);
Close(ddfile);
exit
End;
openefile;
Writehdr('The Database Section');
Repeat
WriteLn(^B^M'Current Database: '^S,curbase.basename);
WriteLn('# of records: '^S,curbase.numents,^M);
q:=menu('Database','DATA','QA*SLVNH%@CD');
Case q Of
2:adddata;
3:selectdata;
4:searchdata;
5:listdata;
6:newscan;
7:newscanall;
8:help('Database.hlp');
9:sysopcommands;
10:changedata;
11:deletedata
End
Until hungupon Or (q=1) Or (FileSize(ddfile)=0);
Close(ddfile);
Close(efile)
End;
Begin
End.